00100	
00200	
00300	(DEFPROP CNVR 
00400	 (NIL CNVR NEWCNUM REALITY1 MFINTERSECT INVISIBLE ORDERED DISPATCH GO1 VLOC TAG INDEX) 
00500	VALUE)
00600	
00700	(DEFPROP NEWCNUM 
00800	 (LAMBDA(LOW HIGH)
00900	  (PROG (N INC INUSE)
01000		(SETQ N (// (PLUS LOW HIGH) 2) INUSE (CNUMSINUSE LOW HIGH) INC 1)
01100	   LOOP (COND ((NOT(AND (GREATERP HIGH N)(GREATERP N LOW))) (CERR NO NEW CNUM BETWEEN (* LOW) AND (* HIGH)))
01200		((MEMBER N INUSE) (SETQ N (PLUS N INC) INC (DIFFERENCE 0 (ADD1 INC))) (GO LOOP))
01300		((RETURN N)))) )
01400	EXPR)
01500	
01600	(DEFPROP REALITY1 
01700	 (LAMBDA(CMARKERS CFRAMES)
01800	  (PROG (CM CON)
01900		(SETQ CON CFRAMES)
02000	   LOOP (SETQ CM (MFINTERSECT))
02100		(COND ((NULL CM) (RETURN NIL)) ((NOT (INVISIBLE (CADR CM) CON)) (RETURN CM)))
02200		(SETQ CMARKERS (CDR CMARKERS) CFRAMES (CDR CFRAMES))
02300		(GO LOOP))) 
02400	EXPR)
02500	
02600	(DEFPROP MFINTERSECT 
02700	 (LAMBDA NIL
02800	  (PROG (NM NF CM)
02900	   ADVANCE
03000		(COND ((AND CMARKERS CFRAMES) (SETQ NF (CADAR CFRAMES) CM (CAR CMARKERS) NM (CAR CM))) ((RETURN NIL)))
03100	   TEST (COND ((> NF NM) (GO A)) ((> NM NF) (GO B)) ((RETURN CM)))
03200	   A    (SETQ CFRAMES (CDR CFRAMES))
03300		(COND ((NULL CFRAMES) (RETURN NIL)))
03400		(SETQ NF (CADAR CFRAMES))
03500		(GO TEST)
03600	   B    (SETQ CMARKERS (CDR CMARKERS))
03700		(COND ((NULL CMARKERS) (RETURN NIL)))
03800		(SETQ CM (CAR CMARKERS))
03900		(SETQ NM (CAR CM))
04000		(GO TEST))) 
04100	EXPR)
04200	
04300	(DEFPROP INVISIBLE 
04400	 (LAMBDA(CNUMS CFRAMES)
04500	  (AND (NOT (EQ CNUMS (QUOTE /+)))
04600	       (OR (NULL CNUMS)
04700		   (PROG (NC NF)
04800			 (SETQ NC (CAR CNUMS))
04900	 	    LOOP (COND (CFRAMES (SETQ NF (CADAR CFRAMES) CFRAMES (CDR CFRAMES))) ((RETURN NIL)))
05000	 	    TEST (COND ((> NF NC) (GO LOOP)) ((> NC NF) (GO A)) ((RETURN NC)))
05100	 	    A    (SETQ CNUMS (CDR CNUMS))
05200			 (COND ((NULL CNUMS) (RETURN NIL)))
05300			 (SETQ NC (CAR CNUMS))
05400			 (GO TEST))))) 
05500	EXPR)
05600	
05700	(DEFPROP ORDERED 
05800	 (LAMBDA(CLIST)
05900	  (OR (NULL CLIST)
06000	      (PROG NIL
06100	       LOOP (COND ((NULL (CDR CLIST)) (RETURN T)) ((NOT (< (CADADR CLIST) (CADAR CLIST))) (RETURN NIL)))
06200		    (SETQ CLIST (CDR CLIST))
06300		    (GO LOOP)))) 
06400	EXPR)
06500	
06600	(DEFPROP DISPATCH 
06700	 (LAMBDA(EXP1 RETAG SAVE ALINK1)
06800	  (COND ((NUMBERP EXP1) (SETQ VAL EXP1) RETAG)
06900		((ATOM EXP1) (SETQ VAL (IVAL EXP1 ALINK1)) RETAG)
07000		(T
07100		 (PROG (V F)
07200		       (SETQ F (CAR EXP1))
07300	 	  BEGIN
07400		       (COND
07500			((ATOM F)
07600			 (COND ((SETQ V (GETL F (QUOTE (CINT CEXPR FEXPR FSUBR)))) (GO (CAR V)))
07700			       (T (SAVEUP) (SETQ UARGS (CDR EXP1) EARGS NIL) (GO A))))
07800			((EQ (CAR F) (QUOTE CLAMBDA)) (SAVEUP)
07900						      (BIND1 (QUOTE *BODY) (CDDR F))
08000						      (SETQ VARS (CADR F) UARGS (CDR EXP1))
08100						      (RETURN (QUOTE ARGB)))
08200			((EQ (CAR F) (QUOTE LAMBDA)) (SAVEUP)
08300						     (SETQ UARGS (CDR EXP1) EARGS NIL)
08400						     (RETURN (QUOTE EVARGS)))
08500			((EQ (CAR F) (QUOTE *CLOSURE)) (SETQ F (CADR F)) (GO BEGIN))
08600			(T (SETQ F (CERR UNKNOWN FUNCTION TYPE (@ . EXP1))) (GO BEGIN)))
08700	 	  A    (RETURN (QUOTE EVARGS))
08800	 	  CINT (SAVEUP)
08900		       (RETURN (CADR V))
09000	 	  CEXPR
09100		       (SAVEUP)
09200		       (BIND1 (QUOTE *BODY) (CDADR V))
09300		       (SETQ VARS (CAADR V) UARGS (CDR EXP1))
09400		       (RETURN (QUOTE ARGB))
09500	 	  FEXPR
09600	 	  FSUBR
09700		       (SETQ VAL (EVAL EXP1))
09800		       (RETURN RETAG))))) 
09900	EXPR)
10000	
10100	(DEFPROP GO1 
10200	 (LAMBDA NIL
10300	  (COND ((ATOM VAL)
10400		 (PROG (FR TAG B)
10500		       (SETQ FR ALINK TAG (QUOTE (: FOO)))
10600		       (RPLACA (CDR TAG) VAL)
10700	 	  LP   (COND ((NULL FR) (SETQ VAL (CERR TAG NOT FOUND)) (QUOTE GO1))
10800			     ((SETQ B (ASSQ (QUOTE *BODY) (BVARS FR)))
10900			      (COND ((SETQ B (MEMBER TAG (CADR B))) (SETQ FRAME* FR) (RESTORE) (SETQ BODY B) (GO A)))))
11000		       (SETQ FR (CLINK FR))
11100		       (GO LP)
11200	 	  A    (RETURN (QUOTE LINE))))
11300		((EQ (CAR VAL) (QUOTE *TAG)) (SETQ FRAME* (CADDR VAL)) (RESTORE))
11400		(T (SETQ VAL (CERR BAD TAG)) (QUOTE GO1)))) 
11500	EXPR)
11600	
11700	(DEFPROP VLOC 
11800	 (LAMBDA N
11900	  (PROG (FR LOC)
12000		(SETQ FR
12100		      (COND ((= N 1) (COND ((SETQ LOC (ASSQ (ARG 1) BVARS)) (RETURN LOC))) ALINK)
12200			    ((= N 2) (FR (ARG 2)))
12300			    (T (CERR WRONG # OF ARGS))))
12400	   LP   (COND ((NULL FR) (RETURN (ASSQ (ARG 1) GLOBALS))) ((SETQ LOC (ASSQ (ARG 1) (BVARS FR))) (GO A)))
12500		(SETQ FR (ALINK FR))
12600		(GO LP)
12700	   A    (RETURN LOC))) 
12800	EXPR)
12900	
13000	(DEFPROP TAG 
13100	 (LAMBDA(NAME)
13200	  (PROG (FR B TAG)
13300		(SETQ FR ALINK TAG (QUOTE (: FOO)))
13400		(RPLACA (CDR TAG) NAME)
13500	   LP   (COND ((NULL FR) (RETURN NIL))
13600		      ((SETQ B (ASSQ (QUOTE *BODY) (BVARS FR)))
13700		       (COND
13800			((SETQ B (MEMBER TAG (CADR B))) (CHAUX FR)
13900							(SETQ B
14000							      (LIST (QUOTE *TAG)
14100	 							    NAME
14200								    (CONS (CONS (LIST (CONS (QUOTE BODY) B))
14300										(QUOTE LINE))
14400									  (CDR FR))))
14500							(GO A)))))
14600		(SETQ FR (CLINK FR))
14700		(GO LP)
14800	   A    (RETURN B))) 
14900	EXPR)
15000	
15100	(DEFPROP INDEX 
15200	 (LAMBDA(THING PATTERN INDEX)
15300	  (PROG (NUM THINGS PFORM)
15400		(COND ((NULL INDEX) (BREAK BAD-INDEX--INDEX T))
15500		      ((EQ (CAR INDEX) (QUOTE *LIST))
15600		       (COND ((EQUAL (SETQ NUM (ADD1 (CADDR INDEX))) *INDEXTHRESHOLD) (RPLACA INDEX (QUOTE *INDEX))
15700										      (SETQ THINGS
15800											    (CDDDR INDEX)
15900	 										    PFORM
16000											    (CADR INDEX))
16100										      (RPLACD
16200										       (CDR INDEX)
16300										       (LIST (LIST NIL) NIL))
16400										      (MAPC (!" LAMBDA
16500												(THING)
16600												(INDEX
16700												 THING
16800												 (@ . PFORM)
16900												 INDEX))
17000	 										    THINGS))
17100			     (T (RPLACD (CDR INDEX) (CONS NUM (CONS THING (CDDDR INDEX)))) (GO A))))
17200		      ((EQ (CAR INDEX) (QUOTE *INDEX)) (SETQ PFORM (CADR INDEX)))
17300		      ((BREAK BAD-INDEX--INDEX T)))
17400		(INDEX1 THING (CAR PATTERN) (CADDR INDEX) (QUOTE CAR) PFORM)
17500		(AND (CDR PATTERN) (INDEX1 THING (CDR PATTERN) (CDDDR INDEX) (QUOTE CDR) PFORM))
17600	   A    (RETURN THING))) 
17700	EXPR)